home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / picglass.cls < prev    next >
Text File  |  1997-06-14  |  9KB  |  259 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "CPictureGlass"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Public Enum EErrorPictureGlass
  13.     eeBasePictureGlass = 13140   ' CPictureGlass
  14.     eePictureNotBitmap           ' Picture must contain bitmap
  15.     eeInvalidCanvas              ' Drawing surface lacks required properties
  16. End Enum
  17.  
  18. Private cvsDst As Object, hdcDst As Long, clrMask As Long
  19. Private hdcImage As Long, hbmpImage As Long, hbmpImageOld As Long
  20. Private hdcMask As Long, hbmpMask As Long, hbmpMaskOld As Long
  21. Private hdcBack As Long, hbmpBack As Long, hbmpBackOld As Long
  22. Private hdcCache As Long, hbmpCache As Long, hbmpCacheOld As Long
  23. Private fExist As Boolean, fVisible As Boolean
  24. Private xOld As Long, yOld As Long
  25. Private dxSrc As Long, dySrc As Long
  26. Private xLeft As Long, yTop As Long
  27.  
  28. Sub Create(cvsDstA As Object, picSrc As Picture, clrMaskA As Long, _
  29.            Optional x As Variant, Optional y As Variant)
  30.     
  31.     ' Clean up any old instance before creating a new one
  32.     If fExist Then Destroy
  33.     ' Save at module level for use in properties and methods
  34.     clrMask = clrMaskA
  35.     Set cvsDst = cvsDstA
  36.     If picSrc.Type <> vbPicTypeBitmap Then ErrRaise eePictureNotBitmap
  37.     
  38.     ' Catch any errors from canvas that doesn't have needed properties
  39.     On Error GoTo CreateErrorCanvas
  40.     With cvsDst
  41.         hdcDst = .hDC
  42.         ' Get size and position of image in pixels
  43.         dxSrc = .ScaleX(picSrc.Width, vbHimetric, vbPixels)
  44.         dySrc = .ScaleY(picSrc.Height, vbHimetric, vbPixels)
  45.         ' Default is the center
  46.         If IsMissing(x) Then x = .ScaleWidth / 2
  47.         If IsMissing(y) Then y = .ScaleHeight / 2
  48.         xLeft = .ScaleX(x, .ScaleMode, vbPixels)
  49.         yTop = .ScaleY(y, .ScaleMode, vbPixels)
  50.     End With
  51.     Dim cPlanes As Long, cPixelBits As Long
  52.     cPlanes = GetDeviceCaps(hdcDst, PLANES)
  53.     cPixelBits = GetDeviceCaps(hdcDst, BITSPIXEL)
  54.     
  55.     ' Create memory DC compatible with screen for picture copy
  56.     Dim hdcSrc As Long, hdcSrcOld As Long, hbmpSrcOld As Long
  57.     hdcSrc = CreateCompatibleDC(0&)
  58.     ' Select bitmap into DC
  59.     hbmpSrcOld = SelectObject(hdcSrc, picSrc.Handle)
  60.     
  61.     ' Create memory DC for image with inverted background (AND mask)
  62.     hdcImage = CreateCompatibleDC(0&)
  63.     ' Create color bitmap same as screen
  64.     hbmpImage = CreateBitmap(dxSrc, dySrc, cPlanes, cPixelBits, 0&)
  65.     hbmpImageOld = SelectObject(hdcImage, hbmpImage)
  66.     ' Make copy of picture because we don't want to modify original
  67.     Call BitBlt(hdcImage, 0, 0, dxSrc, dySrc, hdcSrc, 0, 0, vbSrcCopy)
  68.     
  69.     ' Create DC for monochrome mask of image (XOR mask)
  70.     hdcMask = CreateCompatibleDC(0&)
  71.     ' Create bitmap (monochrome by default)
  72.     hbmpMask = CreateCompatibleBitmap(hdcMask, dxSrc, dySrc)
  73.     ' Select it into DC
  74.     hbmpMaskOld = SelectObject(hdcMask, hbmpMask)
  75.     ' Set background of source to the mask color
  76.     Call SetBkColor(hdcSrc, clrMask)
  77.     ' Copy color bitmap to monochrome DC to create mono mask
  78.     Call BitBlt(hdcMask, 0, 0, dxSrc, dySrc, hdcSrc, 0, 0, vbSrcCopy)
  79.     
  80.     ' We've copied and used the source picture, so give it back
  81.     Call SelectObject(hdcSrc, hbmpSrcOld)
  82.     Call DeleteDC(hdcSrc)
  83.     
  84.     ' Invert background of image to create AND Mask
  85.     Call SetBkColor(hdcImage, vbBlack)
  86.     Call SetTextColor(hdcImage, vbWhite)
  87.     Call BitBlt(hdcImage, 0, 0, dxSrc, dySrc, hdcMask, 0, 0, vbSrcAnd)
  88.                 
  89.     ' Create memory DCs for old background and cache
  90.     hdcBack = CreateCompatibleDC(0&)
  91.     hbmpBack = CreateBitmap(dxSrc, dySrc, cPlanes, cPixelBits, 0&)
  92.     hbmpBackOld = SelectObject(hdcBack, hbmpBack)
  93.     hdcCache = CreateCompatibleDC(0&)
  94.     hbmpCache = CreateBitmap(dxSrc, dySrc, cPlanes, cPixelBits, 0&)
  95.     hbmpCacheOld = SelectObject(hdcCache, hbmpCache)
  96.     
  97.     ' Invalid x and y indicate first move hasn't occurred
  98.     xOld = -1: yOld = -1
  99.     fExist = True: fVisible = True
  100.     Exit Sub
  101. CreateErrorCanvas:
  102.     ErrRaise eeInvalidCanvas
  103. End Sub
  104.  
  105. Private Sub Class_Terminate()
  106.     Destroy
  107. End Sub
  108.  
  109. Sub Destroy()
  110.     BugAssert fExist
  111.     ' Select old mask back to DC
  112.     Call SelectObject(hdcMask, hbmpMaskOld)
  113.     ' Now it's safe to delete DC and bitmask
  114.     Call DeleteDC(hdcMask)
  115.     Call DeleteObject(hbmpMask)
  116.     ' Clean up inverted image DC
  117.     Call SelectObject(hdcImage, hbmpImageOld)
  118.     Call DeleteDC(hdcImage)
  119.     Call DeleteObject(hbmpImage)
  120.     ' Clean up cache DC
  121.     Call SelectObject(hdcCache, hbmpCacheOld)
  122.     Call DeleteDC(hdcCache)
  123.     Call DeleteObject(hbmpCache)
  124.     ' Clean up old background DC
  125.     Call SelectObject(hdcBack, hbmpBackOld)
  126.     Call DeleteDC(hdcBack)
  127.     Call DeleteObject(hbmpBack)
  128.     xOld = -1: yOld = -1
  129.     fExist = False
  130. End Sub
  131.  
  132. Public Sub Draw()
  133. With cvsDst
  134.     BugAssert fExist
  135.     If fVisible = False Then Exit Sub
  136.     
  137.     ' Copy old background to its last location
  138.     If xOld <> -1 Then
  139.         Call BitBlt(hdcDst, xOld, yOld, dxSrc, dySrc, _
  140.                     hdcBack, 0, 0, vbSrcCopy)
  141.     End If
  142.     ' Save current background and position for next time
  143.     Call BitBlt(hdcBack, 0, 0, dxSrc, dySrc, _
  144.                 hdcDst, xLeft, yTop, vbSrcCopy)
  145.     ' Create cache copy of background to work on
  146.     Call BitBlt(hdcCache, 0, 0, dxSrc, dySrc, _
  147.                 hdcDst, xLeft, yTop, vbSrcCopy)
  148.     xOld = xLeft: yOld = yTop
  149.     ' Save color and set to white and black
  150.     Dim clrBack As Long, clrFore As Long
  151.     clrBack = GetBkColor(hdcCache)
  152.     clrFore = GetTextColor(hdcCache)
  153.     Call SetBkColor(hdcCache, vbWhite)
  154.     Call SetTextColor(hdcCache, vbBlack)
  155.     ' Mask the background
  156.     Call BitBlt(hdcCache, 0, 0, dxSrc, dySrc, hdcMask, 0, 0, vbSrcAnd)
  157.     ' Put image in hole created by mask
  158.     Call BitBlt(hdcCache, 0, 0, dxSrc, dySrc, hdcImage, 0, 0, vbSrcPaint)
  159.     ' Restore color
  160.     Call SetBkColor(hdcCache, clrBack)
  161.     Call SetTextColor(hdcCache, clrFore)
  162.     ' Put finished cache on screen
  163.     Call BitBlt(hdcDst, xLeft, yTop, dxSrc, dySrc, _
  164.                 hdcCache, 0, 0, vbSrcCopy)
  165. End With
  166. End Sub
  167.  
  168. Public Sub Remove()
  169.     BugAssert fExist
  170.     If fVisible = False Then Exit Sub
  171.         
  172.     ' Copy the old background to its last location
  173.     If xOld <> -1 Then
  174.         Call BitBlt(hdcDst, xOld, yOld, dxSrc, dySrc, _
  175.                     hdcBack, 0, 0, vbSrcCopy)
  176.     End If
  177. End Sub
  178.  
  179. Public Sub Move(xLeftA As Long, Optional yTopA As Long = -1)
  180. With cvsDst
  181.     BugAssert fExist
  182.     xLeft = .ScaleX(xLeftA, .ScaleMode, vbPixels)
  183.     If yTopA <> -1 Then yTop = .ScaleY(yTopA, .ScaleMode, vbPixels)
  184.     Draw
  185. End With
  186. End Sub
  187.  
  188. Property Get MaskColor() As Long
  189.     BugAssert fExist
  190.     MaskColor = clrMask
  191. End Property
  192.  
  193. Property Get Left() As Single
  194.     BugAssert fExist
  195.     Left = cvsDst.ScaleX(xLeft, vbPixels, cvsDst.ScaleMode)
  196. End Property
  197.  
  198. Property Let Left(rLeft As Single)
  199.     BugAssert fExist
  200.     xLeft = cvsDst.ScaleX(rLeft, cvsDst.ScaleMode, vbPixels)
  201.     Draw
  202. End Property
  203.  
  204. Property Get Top() As Single
  205.     BugAssert fExist
  206.     Top = cvsDst.ScaleY(yTop, vbPixels, cvsDst.ScaleMode)
  207. End Property
  208.  
  209. Property Let Top(rTop As Single)
  210.     BugAssert fExist
  211.     yTop = cvsDst.ScaleY(rTop, cvsDst.ScaleMode, vbPixels)
  212.     Draw
  213. End Property
  214.  
  215. Property Get Width() As Single
  216.     BugAssert fExist
  217.     Width = cvsDst.ScaleX(dxSrc, vbPixels, cvsDst.ScaleMode)
  218. End Property
  219.  
  220. Property Get Height() As Single
  221.     BugAssert fExist
  222.     Height = cvsDst.ScaleY(dySrc, vbPixels, cvsDst.ScaleMode)
  223. End Property
  224.  
  225. Property Get Visible() As Boolean
  226.     BugAssert fExist
  227.     Visible = fVisible
  228. End Property
  229.  
  230. Property Let Visible(fVisibleA As Boolean)
  231.     BugAssert fExist
  232.     fVisible = fVisibleA
  233. End Property
  234. '
  235.  
  236. #If fComponent = 0 Then
  237. Private Sub ErrRaise(e As Long)
  238.     Dim sText As String, sSource As String
  239.     If e > 1000 Then
  240.         sSource = App.ExeName & ".PictureGlass"
  241.         Select Case e
  242.         Case eeBasePictureGlass
  243.             BugAssert True
  244.         Case eePictureNotBitmap
  245.             sText = "Picture must contain bitmap"
  246.         Case eeInvalidCanvas
  247.             sText = "Drawing surface lacks required properties"
  248.         End Select
  249.         Err.Raise COMError(e), sSource, sText
  250.     Else
  251.         ' Raise standard Visual Basic error
  252.         sSource = App.ExeName & ".VBError"
  253.         Err.Raise e, sSource
  254.     End If
  255. End Sub
  256. #End If
  257.  
  258.  
  259.